home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / menusAndKeys.tcl < prev    next >
Encoding:
Text File  |  1997-12-20  |  24.1 KB  |  799 lines  |  [TEXT/ALFA]

  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "menusAndKeys.tcl"
  6.  #                                    created: 12/9/97 {1:43:22 pm} 
  7.  #                                last update: 20/12/97 {6:47:57 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Reorganisation carried out by Vince Darley with much help from Tom 
  15.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  16.  # Alpha is shareware; please register with the author using the register 
  17.  # button in the about box.
  18.  #  
  19.  # 
  20.  #  modified by  rev reason
  21.  #  -------- --- --- -----------
  22.  #  27/11/97 FBO x.x make keys::keyboardChanged use one more item in keyboards
  23.  # ###################################################################
  24.  ##
  25.  
  26. namespace eval menu {}
  27. namespace eval keys {}
  28. namespace eval bind {}
  29.  
  30. ## 
  31.  # -------------------------------------------------------------------------
  32.  # 
  33.  # "menu::bind" --
  34.  # 
  35.  #  Convert a preference of type 'binding' or 'menubinding' into a code
  36.  #  to be inserted into a menu.  Menu-bindings are guaranteed to succeed.
  37.  #  If an ordinary binding contains a prefixChar (e.g. you have bound
  38.  #  ctrl-c followed by ctrl-x to something), then this procedure will
  39.  #  return an empty string, since such bindings cannot appear in menus.
  40.  #  Finally if it is a key-binding and it does not contain a modifier
  41.  #  key, and the key is a normal key (not F1-F12 + few others), then
  42.  #  it will appear in the menu, but the menu will not activate with
  43.  #  that key.  On MacOS, menus can only activate with key-presses
  44.  #  which include a modifier.
  45.  #  
  46.  #  Example usage (from the modeSearchPaths package):
  47.  #  
  48.  #     newPref binding openSelection "<O<B/H" searchPaths
  49.  #     newPref binding sourceHeaderToggle "<O/f" searchPaths
  50.  #   menu::addTo fileUtils \
  51.  #        "[menu::bind searchPathsmodeVars(sourceHeaderToggle) -]" \
  52.  #        "[menu::bind searchPathsmodeVars(openSelection) -]"
  53.  #  
  54.  #  You can adjust these bindings in the package preferences dialog,
  55.  #  but changes will not take effect until you restart Alpha.  Note
  56.  #  that if the user selected menu-incompatible bindings, they would
  57.  #  not operate without the addition of some code to bind them.  One
  58.  #  would need to add this:
  59.  #  
  60.  #   eval bind \
  61.  #     [keys::toBind $searchPathsmodeVars(sourceHeaderToggle)] \
  62.  #     file::sourceHeaderToggle
  63.  #   
  64.  #  The optional arg is the rest of the menu item or '-' which means
  65.  #  use the variable name (if a var) or array element (if an array).
  66.  #  
  67.  #  If the optional argument is given, and the menu item therefore
  68.  #  contains a '/', it is considered to be two dynamic items, the
  69.  #  second of which requires the option key to be used.
  70.  #  
  71.  #  Similarly '//' means use shift, '///' means shift-option,
  72.  #  For instance 'set v /W<O ; menu::bind v close/closeAll//closeFloat'
  73.  #  would give you the menu-item for 'close' in the file menu. 
  74.  # -------------------------------------------------------------------------
  75.  ##
  76. proc menu::bind {var {item ""}} {
  77.     upvar \#0 $var a
  78.     if [regexp {«(.*)»} $a] { set ret "" } else { set ret $a }
  79.     if {$item != ""} {
  80.         if {$item == "-"} {
  81.             regsub -all {([a-zA-Z_:]+\(|\))} $var {} item
  82.         }
  83.         if [regexp {/} $item] {
  84.             set item "<S<E<K$item"
  85.             regsub {///} $item " <S<I<U<K" item
  86.             regsub {//} $item " <S<U<K" item
  87.             regsub {/} $item " <S<I<K" item
  88.             regsub -all {<K} $item $ret ret
  89.         } else {
  90.             append ret $item
  91.         }
  92.     }
  93.     return $ret
  94. }
  95.  
  96. # ◊◊◊◊ flags-menus from prefs ◊◊◊◊ #
  97. # The following four procs allow you to create flag menus with ticks
  98. # very simply.  They adhere to the basic idea of the 'newPref' facility.
  99. proc menu::makeFlagDummy {name {type list}} {
  100.     switch -- $type {
  101.         "array" {
  102.             return [list menu -n $name -p menu::flagProc {}]
  103.         }
  104.         "list" {
  105.             return [list menu -m -n $name -p menu::flagProc {}]
  106.         }
  107.     }
  108. }
  109.  
  110. proc menu::makeFlagMenu {name {type list} {var ""} {in_array ""}} {
  111.     if {$var == ""} { set var $name }
  112.     switch -- $type {
  113.         "array" {
  114.             global $var menu::flagArray allFlags
  115.             set menu::flagArray($name) [list "array" $var]
  116.             foreach i [lsort [array names $var]] {
  117.                 if {[lsearch -exact $allFlags $i] != -1} {
  118.                     lappend items "![lindex {{ } •} [set ${var}($i)]]$i"
  119.                 }
  120.             }
  121.             return [list menu -n $name -p menu::flagProc $items]
  122.         }
  123.         "list" {
  124.             global $var menu::flagArray
  125.             if {$in_array != ""} {
  126.                 set menu::flagArray($name) [list "list" $in_array $var]
  127.                 global $in_array
  128.                 set val [set ${in_array}($var)]
  129.             } else {
  130.                 set menu::flagArray($name) [list "list" $var]
  131.                 set val [set $var]
  132.             }
  133.             set i [lsearch -exact [set items [flag::options $var]] $val]
  134.             if {$i != -1} {
  135.                 set items [lreplace $items $i $i "!•[lindex $items $i]"]
  136.             }
  137.             return [list menu -m -n $name -p menu::flagProc $items]
  138.         }
  139.         default {
  140.             error "Other types not yet supported"
  141.         }
  142.     }
  143. }
  144.  
  145. proc menu::buildFlagMenu {name args} {
  146.     eval [eval menu::makeFlagMenu [list $name] $args]
  147. }
  148.  
  149. proc menu::flagProc {menu flag} {
  150.     global menu::flagArray flag::procs modifiedArrayElements modifiedVars
  151.     set type [set menu::flagArray($menu)]
  152.     set name [lindex $type 1]
  153.     upvar \#0 $name a
  154.     switch -- [lindex $type 0] {
  155.         "array" {
  156.             set a($flag) [expr 1 - $a($flag)]
  157.             if {[info exists flag::procs($flag)]} {
  158.                 [set flag::procs($flag)] $flag
  159.             }
  160.             message "$menu item '$flag' set to $a($flag)"
  161.             markMenuItem $menu $flag $a($flag)
  162.             lunion modifiedArrayElements [list $flag $name]
  163.         }
  164.         "list" {
  165.             if {[set b [lindex $type 2]] == ""} {
  166.                 markMenuItem $menu $a off
  167.                 set a $flag
  168.                 lunion modifiedVars [lindex $type 1]
  169.                 message "[lindex $type 1] set to $flag"
  170.             } else {
  171.                 markMenuItem $menu $a($b) off
  172.                 set a($b) $flag
  173.                 lunion modifiedArrayElements [list [lindex $type 2] [lindex $type 1]]
  174.                 message "$menu set to $flag"
  175.             }
  176.             markMenuItem $menu $flag on
  177.             if {[info exists flag::procs([lindex $type 1])]} {
  178.                 [set flag::procs([lindex $type 1])] $flag
  179.             }
  180.         }
  181.     }
  182. }
  183.  
  184. # ◊◊◊◊ Bindings ◊◊◊◊ #
  185.  
  186. proc menu::bindingsFromArray {arr {include_empty 0}} {
  187.     upvar $arr ar
  188.     set r {}
  189.     foreach a [array names ar] {
  190.         if {[set b $ar($a)] != "" || $include_empty} {
  191.             lappend r "$b$a"
  192.         }
  193.     }
  194.     return $r
  195. }
  196.  
  197. proc bind::fromArray {arr bindarr {unbind 0}} {
  198.     upvar $arr ar
  199.     upvar $bindarr br
  200.     set r {}
  201.     if $unbind {
  202.         set bindcmd "unbind"
  203.     } else {
  204.         set bindcmd "bind"
  205.     }
  206.     foreach a [array names ar] {
  207.         if {[set b $ar($a)] != ""} {
  208.             if [info exists br($a)] {
  209.                 catch {eval $bindcmd [keys::toBind $b] [list $br($a)]}
  210.             } else {
  211.                 beep; message "Bad bind-array entry '$a'"
  212.             }
  213.         }
  214.     }
  215. }
  216.  
  217. ### 
  218.  # -------------------------------------------------------------------------
  219.  # 
  220.  # "keys::verboseKey" --
  221.  # 
  222.  #  Turn a string containing a menu key-code '/x' into a verbose description
  223.  #  of that key.  The optional parameter declares a variable whose value
  224.  #  will be set if the key is a normal key.
  225.  # -------------------------------------------------------------------------
  226.  ##
  227. proc keys::verboseKey {kstr {normal {}}} {
  228.     if {$normal != ""} {upvar $normal n ; set n 0}
  229.     if {![regexp {/(.)} $kstr "" key]} { return "" }
  230.     switch -regexp -- $key {
  231.         {[a-z]} {
  232.             global keys::func
  233.             return [lindex ${keys::func} [expr [text::Ascii $key] - 97]]
  234.         }
  235.         "" {
  236.             return "Left"
  237.         }
  238.         "" {
  239.             return "Right"
  240.         }
  241.         "\x10" {
  242.             return "Up"
  243.         }
  244.         "" {
  245.             return "Down"
  246.         }
  247.         " " {
  248.             return "Space"
  249.         }
  250.         default {
  251.             set n 1
  252.             return $key
  253.         }
  254.     }
  255. }
  256.  
  257. set keys::func {Enter Return Tab "Num Lock" F1 F2 F3 F4 F5 F6 F7 F8 F9 F10 \
  258.     F11 F12 F13 F14 F15 Help Delete "Fwd Del" Home End "Page Up" "Page Down"}
  259.  
  260. set keys::ascii {0x03 0x0d 0x09 0 0 0 0 0 0 0 0 0 0 0 \
  261.     0 0 0 0 0 0 0x08 0 0 0 0 0}
  262.  
  263. set keys::bind {Enter 0x34 0x30 Clear F1 F2 F3 F4 F5 F6 F7 F8 F9 F10 \
  264.  F11 F12 F13 F14 F15 Help 0x33 Del Home End Pgup Pgdn}
  265.  
  266. ## 
  267.  # -------------------------------------------------------------------------
  268.  # 
  269.  # "keys::toBind" --
  270.  # 
  271.  #  Turn a menu key-modifier sequence into something suitable for
  272.  #  a 'bind' statement.  Copes with function keys and arrow keys.
  273.  #  
  274.  #  Use a couple of strings to perform shift-mappings, so that although
  275.  #  the binding says it's bound to 'shift-1', say, in fact it must be
  276.  #  bound to '!' (or shift-'!' which are equivalent), since '!' is a 
  277.  #  shifted '1'.
  278.  #  
  279.  #  You can use 'addcode' to add modifiers.  Mostly useful for pairs
  280.  #  of bindings stored in a single pref in which one is an option/shift
  281.  #  modified version of the other.
  282.  # -------------------------------------------------------------------------
  283.  ##
  284. proc keys::toBind {kstr {addcode {}}} {
  285.     if {![regexp {/(.)} $kstr "" key]} { return "" }
  286.     if [regexp {[a-z]} $key] {
  287.         global keys::bind
  288.         set key [lindex ${keys::bind} [expr [text::Ascii $key] - 97]]
  289.     } elseif {[set i [lsearch -exact {" " "" "" "\x10" ""} $key]] != -1} {
  290.         set key [lindex {0x31 0x7b 0x7c 0x7e 0x7d} $i]
  291.     } else {
  292.         set key [string tolower $key]
  293.     }
  294.     if {[string length $key] == 1} {
  295.         global keys::mapShiftBindFrom keys::mapShiftBindTo
  296.         if {[regexp {[a-z]} $key] || ![regexp {^<U/} $kstr]} {
  297.             set key '${key}' 
  298.         } elseif {[set i [string first $key ${keys::mapShiftBindFrom}]] != -1} {
  299.             set key '[string index ${keys::mapShiftBindTo} $i]'
  300.         } else {
  301.             #alertnote "Weird key: $kstr, please tell Vince."
  302.             # Note from Vince: I think it's ok just to assume we can
  303.             # bind to the key like this, but it's possible there are
  304.             # some problems on international keyboards.  With a U.S.
  305.             # keyboard we should NEVER get here.
  306.             set key '${key}'
  307.         }
  308.     }
  309.     global keys::international
  310.     if [info exists keys::international($key)] {
  311.         set key [set keys::international($key)]
  312.     }
  313.     if {[set a [keys::modifiersTo $kstr$addcode bind]] != ""} {
  314.         return [list $key $a]
  315.     } else {
  316.         return [list $key]
  317.     }
  318. }
  319.  
  320. ## 
  321.  # -------------------------------------------------------------------------
  322.  # 
  323.  # "keys::keyboardChanged" --
  324.  # 
  325.  #  When we change the value of 'keyboards' in the international prefs,
  326.  #  this is called, with the parameter 'keyboards'.
  327.  #  
  328.  #  It is also called at startup, with no parameter.
  329.  #  
  330.  #  Frédéric Boulanger <Frederic.Boulanger@supelec.fr> Nov 27 1997
  331.  #    Added one item to the keyboards items: a list of characters followed
  332.  #    by corresponding key codes.
  333.  #    keys::keyboardChanged now looks for these items and sets 
  334.  #    keys::international to the corresponding key code for each character
  335.  #    in the first list. This is so keys::toBind returns a key code 
  336.  #    instead of a character, which makes bind only bind the given character
  337.  #    and leave the shifted char unbound. The problem arose on a french 
  338.  #    keyboard where '{' is '(' <o> and '[' is '(' <os> . Binding '(' <o>
  339.  #    to bind::LeftBrace also binds '(' <os> to bind::LeftBrace, so it was
  340.  #    impossible to type a '['. To avoid this problem, we have to bind
  341.  #    0x17 <o> to bind::LeftBrace, where 0x17 is the key code for '(' on a
  342.  #    french keyboard.
  343.  #    For other keyboards, I don't know the key codes, so if you have the
  344.  #    same problem with bindings, you may change the definition of your 
  345.  #    keyboard in alphaDefinitions.tcl to solve it.
  346.  # -------------------------------------------------------------------------
  347.  ##
  348. proc keys::keyboardChanged {{flag "startup"}} {
  349.     global keyboards keyboard keys::mapShiftBindFrom keys::mapShiftBindTo \
  350.       modifiedVars oldkeyboard bind::LeftBrace bind::RightBrace keys::international
  351.     if {$oldkeyboard != ""} {
  352.         namespace eval ::alpha [list catch "unbind [keys::toBind ${bind::LeftBrace}] bind::LeftBrace"]
  353.         namespace eval ::alpha [list catch "unbind [keys::toBind ${bind::RightBrace}] bind::RightBrace"]
  354.         set i 0
  355.         foreach k [lindex $keyboards($oldkeyboard) 4] {
  356.             if {[incr i] % 2} {catch {unset keys::international($k)}}
  357.         }
  358.         catch {unset keys::international}
  359.         hook::callAll removekeyboard $oldkeyboard
  360.     }
  361.     # set new values
  362.     set keys::mapShiftBindFrom [lindex $keyboards($keyboard) 0]
  363.     set keys::mapShiftBindTo [lindex $keyboards($keyboard) 1]
  364.     set bind::LeftBrace [lindex $keyboards($keyboard) 2]
  365.     set bind::RightBrace [lindex $keyboards($keyboard) 3]
  366.     if {[llength $keyboards($keyboard)] >= 5} {
  367.         array set keys::international [lindex $keyboards($keyboard) 4]
  368.     }
  369.     # bind
  370.     namespace eval ::alpha [list catch "bind [keys::toBind ${bind::LeftBrace}] bind::LeftBrace"]
  371.     namespace eval ::alpha [list catch "bind [keys::toBind ${bind::RightBrace}] bind::RightBrace"]
  372.     # Call anything that's been registered to the new keyboard
  373.     # (Usually a proc to change some menu-bindings).  Use:   
  374.     #   hook::register keyboard "Swiss French" my-proc
  375.     hook::callAll keyboard $keyboard
  376.     if {$oldkeyboard != ""} {
  377.         lappend modifiedVars keyboard
  378.         alertnote "Changing the keyboard may require you to restart\
  379.           Alpha for the bindings to be set correctly."
  380.     }
  381.     set oldkeyboard $keyboard
  382. }
  383.  
  384. proc bind::fromPref {f {un ""}} {
  385.     global flag::binding
  386.     if [info exists flag::binding($f)] {
  387.         set m [lindex [set flag::binding($f)] 0]
  388.         if {[set proc [lindex [set flag::binding($f)] 1]] == 1} {
  389.             set proc $f
  390.         }
  391.         namespace eval ::alpha [list catch "${un}bind [keys::toBind $old] [list $proc] $m"]
  392.     }
  393. }
  394.  
  395. ## 
  396.  # -------------------------------------------------------------------------
  397.  # 
  398.  # "keys::modifiersTo" --
  399.  # 
  400.  #  Turn a menu-modifier sequence into something else.  Options are 
  401.  #  'verbose' (a textual description), 'bind' (a binding code-sequence),
  402.  #  and 'menu' which just returns what was given.
  403.  # -------------------------------------------------------------------------
  404.  ##
  405. proc keys::modifiersTo {key type} {
  406.     set key1 {}
  407.     switch -- $type {
  408.         "verbose" {
  409.             if [regexp {«(.)»} $key d pref] {
  410.                 if {$pref == "e"} {
  411.                     append key1 "escape "
  412.                 } else {
  413.                     append key1 "ctrl-$pref "
  414.                 }
  415.             }
  416.             if [regexp {<U} $key] {append key1 "shift-"}
  417.             if [regexp {<B} $key] {append key1 "ctrl-"}
  418.             if [regexp {<I} $key] {append key1 "opt-"}
  419.             if [regexp {<O} $key] {append key1 "cmd-"}
  420.             return $key1
  421.         }
  422.         "tksym" {
  423.             if [regexp {«(.)»} $key d pref] {
  424.                 if {$pref == "e"} {
  425.                     append key1 "Escape "
  426.                 } else {
  427.                     append key1 "Control-$pref "
  428.                 }
  429.             }
  430.             if [regexp {<U} $key] {append key1 "Shift-"}
  431.             if [regexp {<B} $key] {append key1 "Control-"}
  432.             if [regexp {<I} $key] {append key1 "Option-"}
  433.             if [regexp {<O} $key] {append key1 "Command-"}
  434.             return $key1
  435.         }
  436.         "bind" {
  437.             if [regexp {<U} $key] {append key1 "s"}
  438.             if [regexp {<B} $key] {append key1 "z"}
  439.             if [regexp {<I} $key] {append key1 "o"}
  440.             if [regexp {<O} $key] {append key1 "c"}
  441.             if [regexp {«(.)»} $key d pref] {
  442.                 append key1 $pref
  443.             }
  444.             if {$key1 != ""} {
  445.                 return "<${key1}>"
  446.             } else {
  447.                 return ""
  448.             }
  449.         }
  450.         "menu" {
  451.             if [regexp {«(.)»} $key d pref] {
  452.                 return ""
  453.             } else {
  454.                 return $key
  455.             }
  456.         }
  457.     }
  458. }
  459.  
  460. ## 
  461.  # -------------------------------------------------------------------------
  462.  # 
  463.  # "keys::bindToMenu" --
  464.  # 
  465.  #  Doesn't yet cope with function keys etc, nor 0x31 type bindings,
  466.  #  nor prefixChars (which can't go in a menu anyway).
  467.  # -------------------------------------------------------------------------
  468.  ##
  469. proc keys::bindToMenu {i} {
  470.     regexp {'(.)'[ \t]*<([^>]+)>} $i d key mods
  471.     set key "/[string toupper $key]"
  472.     if [regexp {s} $mods] {append key "<U"}
  473.     if [regexp {z} $mods] {append key "<B"}
  474.     if [regexp {o} $mods] {append key "<I"}
  475.     if [regexp {c} $mods] {append key "<O"}
  476.     return $key
  477. }
  478.     
  479. ## 
  480.  # -------------------------------------------------------------------------
  481.  # 
  482.  # "keys::findPrefixChars" --
  483.  # 
  484.  #  This proc is rather slow, since it has to scan an enormous list of
  485.  #  bindings.  However since it is only used from the dialog below,
  486.  #  that doesn't matter too much (i.e. it is quick enough on my machine).
  487.  # -------------------------------------------------------------------------
  488.  ##
  489. proc keys::findPrefixChars {} {
  490.     set menu ""
  491.     foreach i [keys::findBindingsTo "prefixChar"] {
  492.         if ![regexp {'(.)'[ \t]*<z>} $i d key] {
  493.             beep; message "A bad prefix char has been defined: bind $i prefixChar, this will not work."
  494.         } else {
  495.             lappend menu [string toupper $key]
  496.         }
  497.     }
  498.     return $menu
  499. }
  500.  
  501. proc keys::findBindingsTo {to {mode ""} {lines 0}} {
  502.     if {$mode == "*"} { set mode "(\\w+)?" }
  503.     set t [bindingList]
  504.     set pref ""
  505.     while {[regexp -indices "\rbind(\[^\r\]+) $to *${mode} *\r" $t d idx]} {
  506.         if $lines {
  507.             lappend pref [string trim [eval string range [list $t] $d]]
  508.         } else {
  509.             lappend pref [string trim [eval string range [list $t] $idx]]
  510.         }
  511.         set t [string range $t [lindex $idx 1] end]
  512.     }
  513.     return $pref
  514. }
  515.  
  516. proc keys::findBindingsOf {of {mode ""}} {
  517.     if {$mode == "*"} { set mode "(\\w+)?" }
  518.     set t [bindingList]
  519.     set pref ""
  520.     while {[regexp -indices "\rbind[quote::WhitespaceReg " ${of} "](\[\\w:\]+) *${mode} *\r" $t l idx]} {
  521.         lappend pref [string trim [eval string range [list $t] $l]]
  522.         set t [string range $t [lindex $idx 1] end]
  523.     }
  524.     return $pref
  525. }
  526.  
  527. proc keys::unsetBinding {v {mode ""}} {
  528.     foreach i [keys::findBindingsOf $v $mode] {
  529.         regsub {' '} $i {0x31} i
  530.         eval "un${i}"
  531.     }
  532. }
  533.  
  534. proc keys::bindPackage {pkg} {
  535.     global ${pkg}modeVars flag::type flag::binding
  536.     foreach v [array names ${pkg}modeVars] {
  537.         if {[info exists flag::type($v)] && [set flag::type($v)] == "binding"} {
  538.             if [info exists flag::binding($v)] {
  539.                 set m [lindex [set flag::binding($v)] 0]
  540.                 if {[set proc [lindex [set flag::binding($v)] 1]] == 1} {
  541.                     set proc $v
  542.                 }
  543.                 namespace eval ::alpha [list catch "bind [keys::toBind [set ${pkg}modeVars($v)]] [list $proc] $m"]
  544.             }
  545.         }
  546.     }
  547. }
  548.  
  549. # ◊◊◊◊ Key presses ◊◊◊◊ #
  550. namespace eval key {}
  551.  
  552. proc key::optionPressed {{m ""}} {
  553.     if {$m == ""} {set m [getModifiers]}
  554.     expr $m & 72
  555. }
  556. proc key::shiftPressed {{m ""}} {
  557.     if {$m == ""} {set m [getModifiers]}
  558.     expr $m & 34
  559. }
  560. proc key::controlPressed {{m ""}} {
  561.     if {$m == ""} {set m [getModifiers]}
  562.     expr $m & 144
  563. }
  564. proc key::cmdPressed {{m ""}} {
  565.     if {$m == ""} {set m [getModifiers]}
  566.     expr $m & 1
  567. }
  568.  
  569. namespace eval prompt {}
  570. ## 
  571.  # -------------------------------------------------------------------------
  572.  # 
  573.  # "prompt::keyMenuCode" --
  574.  # 
  575.  #  'getChar' is modified by ctrl and option, so if the user presses one
  576.  #  of them, we have to request the key again.  Also if the user pressed
  577.  #  shift and the key wasn't A-Z, then we also have to ask again.  Finally
  578.  #  if the key pressed was a non-ascii one, we have to select from a menu.
  579.  #  
  580.  #  This function is an alternative to 'dialog::getAKey'.  Hence it takes
  581.  #  the same parameters, except it ignores some of them.
  582.  #  
  583.  #  Doesn't currently deal with the 'for_menu' flag which it should.
  584.  # -------------------------------------------------------------------------
  585.  ##
  586. proc prompt::getAKey {{name ""} {keystr ""} {for_menu 1}} {
  587.     beep ; message "Press the key and modifiers"
  588.     set char [string toupper [getChar]]
  589.     set mod [getModifiers]
  590.     if {$mod & 0xd8 || ($mod & 0x22) && ![regexp {[A-Z]} $char]} {
  591.         beep; message "Please press the key again, this time without modifiers."
  592.         set char [string toupper [getChar]]
  593.     }
  594.     if ![regexp {[][=A-Z0-9`\\';,./-]} $char] {
  595.         global keys::ascii keys::func
  596.         set ascii [text::Ascii $char]
  597.         if {$ascii > 27 && $ascii < 32} {
  598.             set char [lindex {"" "" "\x10" ""} [expr $ascii - 27]]
  599.         }
  600.         set i 0
  601.         foreach k ${keys::ascii} { 
  602.             if [expr $k == $ascii] { 
  603.                 set char [text::Ascii [expr $char + 97] 1]
  604.                 break
  605.             }
  606.             incr i
  607.         }
  608.         if {$i == [llength ${keys::ascii}]} {
  609.             set char [dialog::optionMenu \
  610.                 "This procedure cannot isolate which key that was.  You'll have to select it manually" ${keys::func} "" 1]
  611.             set char [text::Ascii [expr $char + 97] 1]
  612.         }
  613.     }
  614.     set res [keys::modToMenu $mod $char]
  615.     if {!$for_menu} {
  616.         beep; message "If there is a prefix-char, hit that now (without the ctrl-key) else return."
  617.         set char [string toupper [getChar]]
  618.         if {[text::Ascii $char] == 27} { set char "e" } 
  619.         if [regexp -nocase {[a-z]} $char] {append res "«$char»"}
  620.     }
  621.     return $res
  622. }
  623.  
  624. ## 
  625.  # cmdKey                      = 0x01,
  626.  # shiftKey                    = 0x02,
  627.  # alphaLock                   = 0x04,
  628.  # optionKey                   = 0x08,
  629.  # controlKey                  = 0x10,
  630.  # rightShiftKey               = 0x20,
  631.  # rightOptionKey              = 0x40,
  632.  # rightControlKey             = 0x80,
  633.  ##
  634. # 'char' must be upper case, if it really is a char.
  635. proc keys::modToMenu {mod {char ""}} {
  636.     if {$char != ""} {
  637.         set t "/${char}"
  638.     } else {
  639.         set t ""
  640.     }
  641.     # cmd
  642.     if {[expr $mod & 1]} { append t "<O" }
  643.     # shift
  644.     if {[expr $mod & 2 |  $mod & 32]} { append t "<U" }
  645.     # option
  646.     if {[expr $mod & 8 | $mod & 64]} { append t "<I" }
  647.     # ctrl
  648.     if {[expr $mod & 16 | $mod & 128]} { append t "<B" }
  649.     return $t
  650. }
  651.  
  652. proc global::specialKeys {} {
  653.     global keys::specialBindings keys::specialProcs modifiedArrVars
  654.     # unbind old set
  655.     bind::fromArray keys::specialBindings keys::specialProcs 1
  656.     
  657.     hook::callAll specialKeys *
  658.     
  659.     if [catch {dialog::arrayBindings "Special keys" keys::specialBindings}] {
  660.         # cancelled so rebind old set
  661.         bind::fromArray keys::specialBindings keys::specialProcs
  662.         return
  663.     }
  664.     # bind new set
  665.     bind::fromArray keys::specialBindings keys::specialProcs
  666.     # perhaps do something else?
  667.     lappend modifiedArrVars keys::specialBindings
  668. }
  669.  
  670.  
  671. ## 
  672.  # -------------------------------------------------------------------------
  673.  # 
  674.  # "alpha::basicKeyBindings" --
  675.  # 
  676.  #  Bind all the obvious stuff, so cursor keys etc actually work!
  677.  # -------------------------------------------------------------------------
  678.  ##
  679. proc alpha::basicKeyBindings {} {
  680.     bind Left  backwardChar
  681.     bind Left <c> beginningOfLine
  682.     bind Left <s> backwardCharSelect
  683.     bind Left <sc> beginningLineSelect
  684.     bind Left <z> {scrollLeftCol 15}
  685.     bind Left <o> backwardWord
  686.     bind Left <os> backwardWordSelect
  687.     
  688.     bind Right  forwardChar
  689.     bind Right <c> endOfLine
  690.     bind Right <s> forwardCharSelect
  691.     bind Right <sc> endLineSelect
  692.     bind Right <z> {scrollRightCol 15}
  693.     bind Right <o> forwardWord
  694.     bind Right <os> forwardWordSelect
  695.     
  696.     bind Up        previousLine
  697.     bind Up <s>    prevLineSelect
  698.     bind Up <c>    beginningOfBuffer
  699.     bind Up <sc>   beginningBufferSelect
  700.     bind Up <z>    scrollUpLine
  701.     bind Up <o>    scrollUpLine
  702.     
  703.     bind Down      nextLine
  704.     bind Down <c>  endOfBuffer
  705.     bind Down <s>  nextLineSelect
  706.     bind Down <sc> endBufferSelect
  707.     bind Down <z>  scrollDownLine
  708.     bind Down <o>  scrollDownLine
  709.     
  710.     # Keypad definitions
  711.     bind KPad4     backwardWord                 
  712.     bind KPad4 <c> backwardDeleteWord 
  713.     bind KPad6     forwardWord                 
  714.     bind KPad6 <c> deleteWord 
  715.     bind Clear     toggleNumLock
  716.     # Never bind Keypad /
  717.     # Never bind Keypad *
  718.     bind KPad0     nextWindow
  719.     bind KPad0 <s> prevWindow
  720.     bind KPad+     nextWindow
  721.     bind KPad-     prevWindow
  722.     bind KPad0       pageBack
  723.     # bind Enter   pageForward
  724.     bind Enter       briefThing
  725.     bind Kpad1     prevFunc
  726.     bind Kpad3     nextFunc
  727.     bind KPad.     endOfBuffer                 
  728.     bind KPad5     exchangePointAndMark     
  729.     bind KPad7     backwardDeleteWord         
  730.     bind KPad9     deleteWord                 
  731.     
  732.     bind Help       alphaHelp                     
  733.     bind Home       beginningOfBuffer             
  734.     bind End        endOfBuffer                 
  735.     bind Pgup       pageBack                     
  736.     bind Pgdn       pageForward                  
  737.     bind Del        deleteChar                 
  738.     bind 0x33        deleteChar                 
  739. }
  740.  
  741. ## 
  742.  # -------------------------------------------------------------------------
  743.  # 
  744.  # "alpha::keyBindings" --
  745.  # 
  746.  #  Bind some 'standard' alpha key-bindings
  747.  # -------------------------------------------------------------------------
  748.  ##
  749. proc alpha::keyBindings {} {
  750.     bind Del   <z> forwardDeleteWhitespace
  751.     bind 0x33   <z> forwardDeleteWhitespace
  752.     bind Del        backSpace
  753.     bind 0x33        backSpace
  754.     
  755.     bind 't' <z>     insertToTop        
  756.     bind 'z' <z>     pageBack
  757.     bind '\ ' <z>     setMark
  758.     bind '1' <z>    execAbbrev
  759.  
  760.     # Another control prefix.
  761.     bind 'q' <z>     prefixChar
  762.     bind 't' <Q>    shrinkHigh
  763.     bind 'b' <Q>    shrinkLow
  764.     bind 'l' <Q>    shrinkLeft
  765.     bind 'r' <Q>    shrinkRight
  766.     bind 'c' <Q>    chooseAWindow
  767.     bind 'h' <Q>    winhorizontally
  768.     bind 'i' <Q>    iconify
  769.     bind 'n' <Q>    nextWindow
  770.     bind 'o' <Q>    bufferOtherWindow
  771.     bind 'p' <Q>    prevWindow
  772.     bind 's' <Q>    swapWithNext
  773.     bind 'a' <Q>    wintiled
  774.     bind 'v' <Q>    winvertically
  775.     bind 'f' <Q>    shrinkFull
  776.     bind '2' <Q>    splitWindow
  777.     
  778.     bind '\ ' <o>    oneSpace
  779.     bind Esc    startEscape
  780.     bind 'f' <cz>     freeMem
  781.     bind 'h' <z>    hiliteWord
  782.     
  783.     bind 'm' <X>    matchingLines 
  784.     bind 's' <ze> regIsearch
  785.     bind 'l' <C> dividingLine
  786.     
  787.     # global binding for CR
  788.     bind '\r'       bind::CarriageReturn
  789.     bind   F1         bind::Completion     
  790.     bind '\[' <zs>  normalLeftBrace
  791.     bind '\]' <zs>  normalRightBrace
  792.     # Useful for C-like-modes
  793.     bind '\;'      bind::electricSemi
  794.     bind '\;' <z> "insertText {;}"
  795.     bind 'l' <z> centerRedraw
  796.     bind 'l' <oz> refresh
  797. }
  798.  
  799.